Gold Medal Software 3/Gold Medal Software - Volume 3 (Gold Medal) (1994).iso/windows/editprog/newvisda.arj/DYNAGRID.FRM

Text File | 1994-04-02 | 19KB | 736 lines

VERSION 2.00
Begin Form fGridFrm
   BackColor       =   &H00C0C0C0&
   ClientHeight    =   3105
   ClientLeft      =   930
   ClientTop       =   3585
   ClientWidth     =   6690
   Height          =   3570
   Icon            =   DYNAGRID.FRX:0000
   Left            =   840
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3096
   ScaleMode       =   0  'User
   ScaleWidth      =   6708
   Tag             =   "Dynaset"
   Top             =   3210
   Width           =   6870
   Begin Grid cGrid
      FixedCols       =   0
      FixedRows       =   0
      Height          =   2412
      Left            =   0
      TabIndex        =   0
      Top             =   480
      Width           =   6732
   End
   Begin PictureBox ViewButtons
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   375
      Left            =   0
      ScaleHeight     =   372
      ScaleMode       =   0  'User
      ScaleWidth      =   5171.607
      TabIndex        =   1
      Top             =   24
      Width           =   5175
      Begin CommandButton SortButton
         Caption         =   "&Sort"
         Height          =   372
         Left            =   3720
         TabIndex        =   9
         Top             =   0
         Width           =   612
      End
      Begin CommandButton FilterButton
         Caption         =   "Fil&ter"
         Height          =   372
         Left            =   3120
         TabIndex        =   8
         Top             =   0
         Width           =   612
      End
      Begin CommandButton RefreshButton
         Caption         =   "&Redo"
         Height          =   372
         Left            =   2520
         TabIndex        =   7
         Top             =   0
         Width           =   612
      End
      Begin CommandButton CloseButton
         Cancel          =   -1  'True
         Caption         =   "&Close"
         Height          =   372
         Left            =   4320
         TabIndex        =   6
         Top             =   0
         Width           =   612
      End
      Begin CommandButton MoreButton
         Caption         =   "&More"
         Height          =   372
         Left            =   1320
         TabIndex        =   5
         Top             =   0
         Width           =   612
      End
      Begin CommandButton NextButton
         Caption         =   "&Next"
         Height          =   372
         Left            =   120
         TabIndex        =   4
         Top             =   0
         Width           =   612
      End
      Begin CommandButton FirstButton
         Caption         =   "&First"
         Height          =   372
         Left            =   720
         TabIndex        =   3
         Top             =   0
         Width           =   612
      End
      Begin CommandButton FindButton
         Caption         =   "F&ind"
         Height          =   372
         Left            =   1920
         TabIndex        =   2
         Top             =   0
         Width           =   612
      End
   End
End
Option Explicit

'form variables
'Dim FDS As dynaset         'current form's dynaset
Dim FDS As snapshot        'current form's snapshot
Dim FDynSt As String       'dynaset open string
Dim FTblName As String     'form dynaset table name
Dim FCurrentRow As Long    'current row in dynaset
Dim FGridRow As Integer    'current grid row
Dim FNotFound As Integer   'find not found flag
Dim FFindForm As New fFind 'find form
Dim FNumbRows As Long      'total number of rows in table
Dim FDynaString As String  'dynaset open string

Sub cGrid_DblClick ()
  Dim r As Integer       'return from execute sql
  Dim fn As String       'field name

  On Error GoTo ZoomErr
  r = cGrid.Row
  cGrid.Row = 0
  'get field name
  fn = cGrid.Text
  cGrid.Row = r

  'make sure it's a string or memo field
  If FDS(fn).Type = FT_STRING Or FDS(fn).Type = FT_MEMO Then
     gstZoomData = cGrid.Text
     fZoom.Caption = fn
     fZoom.Top = Top + 1200
     fZoom.Left = Left + 250
     fZoom.CloseZoomButton.Visible = True
     fZoom.Show MODAL
  End If
  GoTo ZoomEnd

ZoomErr:
  ShowError
  Resume ZoomEnd

ZoomEnd:

End Sub

Sub cGrid_KeyUp (KeyCode As Integer, Shift As Integer)
  'zoom on F4 key press
  If KeyCode = &H73 Then   'F4
    cGrid_DblClick
  End If
End Sub

Sub CloseButton_Click ()
  Unload Me
End Sub

Sub FilterButton_Click ()
  On Error GoTo FilterErr

'  Dim ds1 As dynaset, ds2 As dynaset
  Dim ds1 As snapshot, ds2 As snapshot

  Dim numbrows As Long    'local number of rows

  Set ds1 = FDS            'save the dynaset

 Dim i As Integer, r As Integer, c As Integer

   'On Error GoTo FindErr

   'load the column names into the filter form
   'the 1st time it is loaded
   If fFilter.cFieldList.ListCount = 0 Then
     fFilter.cFieldList.Clear
     r = cGrid.Row
     c = cGrid.Col
     cGrid.Row = 0
     cGrid.Col = 0
     For i = 1 To cGrid.Cols - 1
       cGrid.Col = cGrid.Col + 1
       fFilter.cFieldList.AddItem cGrid.Text
     Next
     cGrid.Row = r
     cGrid.Col = c
   End If

   MsgBar "Enter Search Parameters", False

  fFilter.Show MODAL


  'FilterStr = InputBox("Enter Filter Expression:")
  If FilterStr = "" Then Exit Sub

  FDS.Filter = FilterStr
'  Set ds2 = FDS.CreateDynaset()            'establish the filter
  Set ds2 = FDS.CreateSnapshot()            'establish the filter
  Set FDS = ds2            'assign back to original dynaset object

  'everything must be okay so redisplay form on 1st record
  FNumbRows = GetNumbRecsSS(FDS)          'query numb of recs
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     Caption = "Dynaset: " + FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48

     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " rows]"
   End If
  If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then
    Unload Me
    Exit Sub
  End If
  GoTo FilterEnd

FilterErr:
  ShowError
  Set FDS = ds1            're-assign back to original
  Resume FilterEnd

FilterEnd:

End Sub

Sub FindButton_Click ()
   Dim i As Integer, r As Integer, c As Integer

   On Error GoTo FindErr

   'load the column names into the find form
   'the 1st time it is loaded
   If FFindForm.cFieldList.ListCount = 0 Then
     FFindForm.cFieldList.Clear
     r = cGrid.Row
     c = cGrid.Col
     cGrid.Row = 0
     cGrid.Col = 0
     For i = 1 To cGrid.Cols - 1
       cGrid.Col = cGrid.Col + 1
       FFindForm.cFieldList.AddItem cGrid.Text
     Next
     cGrid.Row = r
     cGrid.Col = c
   End If

FindStart:       'used to loop around on not found

   'reset the flags
   gfFindFailed = False
   gfFromTableView = True

   MsgBar "Enter Search Parameters", False

   FFindForm.Show MODAL

   MsgBar "Searching for record", True

   If gfFindFailed = True Then Exit Sub

   FNotFound = False

   SetHourGlass Me

   'search for the record
   cGrid.SetFocus        'start at the top
   SendKeys "^{Home}"
   cGrid.Col = 1
   cGrid.Row = 0
   'move the right column
   While cGrid.Text <> UCase(gstFindField)
     If cGrid.Col = cGrid.Cols Then 'reached max col
     Else
       cGrid.Col = cGrid.Col + 1
       SendKeys "{Right}"
     End If
   Wend
   cGrid.Row = 1
   While cGrid.Row < cGrid.Rows - 1
       If gfFindMatch = False Then
         Select Case gstFindOp
           Case "="
             If UCase(cGrid.Text) = UCase(gstFindExpr) Then GoTo AfterWhile
           Case "<>"
             If UCase(cGrid.Text) <> UCase(gstFindExpr) Then GoTo AfterWhile
           Case ">="
             If UCase(cGrid.Text) >= UCase(gstFindExpr) Then GoTo AfterWhile
           Case "<="
             If UCase(cGrid.Text) <= UCase(gstFindExpr) Then GoTo AfterWhile
           Case ">"
             If UCase(cGrid.Text) > UCase(gstFindExpr) Then GoTo AfterWhile
           Case "<"
             If UCase(cGrid.Text) < UCase(gstFindExpr) Then GoTo AfterWhile
           Case "Like"
             If UCase(cGrid.Text) Like UCase(gstFindExpr) Then GoTo AfterWhile
         End Select
       Else
         Select Case gstFindOp
           Case "="
             If cGrid.Text = gstFindExpr Then GoTo AfterWhile
           Case "<>"
             If cGrid.Text <> gstFindExpr Then GoTo AfterWhile
           Case ">="
             If cGrid.Text >= gstFindExpr Then GoTo AfterWhile
           Case "<="
             If cGrid.Text <= gstFindExpr Then GoTo AfterWhile
           Case ">"
             If cGrid.Text > gstFindExpr Then GoTo AfterWhile
           Case "<"
             If cGrid.Text < gstFindExpr Then GoTo AfterWhile
           Case "Like"
             If cGrid.Text Like gstFindExpr Then GoTo AfterWhile
         End Select
       End If
     cGrid.Row = cGrid.Row + 1
     SendKeys "{Down}"
   Wend
   FNotFound = True       'didn't find it

AfterWhile:
   ResetMouse Me

   'show the first record
   If FNotFound Then
     Beep
     MsgBox "Record Not Found", 48
     GoTo FindStart
   End If
   DoEvents
   cGrid.SelStartRow = cGrid.Row
   cGrid.SelStartCol = 1
   cGrid.SelEndRow = cGrid.Row
   cGrid.SelEndCol = FDS.Fields.Count

   GoTo FindEnd

FindErr:
   ResetMouse Me
   ShowError
   Resume FindEnd

FindEnd:
   MsgBar "", False

End Sub

Sub FirstButton_Click ()
   Dim numbrows As Long         'number of rows

   On Error GoTo GoFirstError

   SetHourGlass Me
   MsgBar "Going to first record", True
   cGrid.SetFocus
   cGrid.Row = 1
   cGrid.Col = 0
   'get current starting row in grid
   If cGrid.Text <> "1" Then
     FDS.Close
'     Set FDS = gCurrentDB.CreateDynaset(FDS.Name)
     Set FDS = gCurrentDB.CreateSnapshot(FDS.Name)

     FNumbRows = GetNumbRecsSS(FDS)
     If FNumbRows > gwMaxGridRows Then
       numbrows = gwMaxGridRows
       FCurrentRow = numbrows
     Else
       numbrows = FNumbRows
     End If

     If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then
       Unload Me
       Exit Sub
     End If
  End If
  cGrid.Col = 1
  SendKeys "{Home}"

  GoTo GoFirstEnd

GoFirstError:
  ShowError
  Resume GoFirstEnd

GoFirstEnd:
  ResetMouse Me
  MsgBar "", False

End Sub

Sub Form_Load ()
   Dim t As TableDef       'local table structure
   Dim sp As Integer       'starting point of table name
   Dim ep As Integer       'ending point of table name
   Dim wh As String        'where clause

   Dim i As Integer, j As Integer
   Dim fn As String        'field name
   Dim rc As Integer       'record count
   Dim numbrows As Long    'local number of rows
   Dim ss As snapshot

   Dim Start1, Finish1, Start2, Finish2

   On Error GoTo DynasetErr

   SetHourGlass Me
   MsgBar "Opening Dynaset", True

   'assign the temp string with the select statement
   'if it is not empty, otherwise, use the table list name
   If gfFromSQL = True Then
     If gstDynaString = "" Then
       FDynSt = fSQL.cSQLStatement
     Else
       FDynSt = gstDynaString
     End If
   Else
     FDynSt = fTables.cTableList
   End If

   'attemp to open the dynaset
   Start1 = Timer
   If UCase(FDynSt) = "LISTTABLES" Then
     Set FDS = gCurrentDB.ListTables()
   Else
     If gfFromSQL = True And fSQL.cPassThru = 1 Then
'       Set FDS = gCurrentDB.CreateDynaset(FDynSt, VBDA_SQLPASSTHROUGH)
       Set FDS = gCurrentDB.CreateSnapshot(FDynSt, VBDA_SQLPASSTHROUGH)
     Else
'       Set FDS = gCurrentDB.CreateDynaset(FDynSt)
       Set FDS = gCurrentDB.CreateSnapshot(FDynSt)
     End If
   End If
   Finish1 = Timer

   Start2 = Timer
   'parse off table name to store in global gstTblName
   wh = ""
   sp = InStr(1, UCase(FDynSt), "FROM")
   If sp > 0 Then
     'must be a "select from" statement
     sp = sp + 5
     For ep = sp To Len(FDynSt)
       'search for a space or the end of FDynSt
       If Mid$(FDynSt, ep, 1) = " " Then
         'get where clause if there is one
         wh = Mid$(FDynSt, sp, Len(FDynSt) - sp + 1)
         Exit For
       End If
     Next
     FTblName = UCase(Mid$(FDynSt, sp, ep - sp))
     If wh = "" Then wh = FTblName
   Else
     'must be a table name only
     FTblName = UCase(FDynSt)
     wh = FTblName
   End If

   FDynaString = wh

   'show the first record
   FNumbRows = GetNumbRecsSS(FDS)          'query numb of recs

   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     Caption = "SnapShot: " + FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     Caption = "SnapShot: " + FTblName + " [" + CStr(FNumbRows) + " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     Caption = "SnapShot: " + FTblName + " [" + CStr(FNumbRows) + " rows]"
   End If

   If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then
     ResetMouse Me
     Unload Me
     Exit Sub
   End If
   If numbrows < 50 Then
   Height = 3800 + numbrows * 20
   Else
   Height = 5000
   End If
   Width = 5450 + SumColwid / 2
   'Left = 1000
   'Top = 1000

   Finish2 = Timer
   If VDMDI.PrefShowPerf.Checked Then
     Me.Show
     MsgBox CStr(FNumbRows) + " rows found in " + CStr(Finish1 - Start1) + " seconds!" + Chr(13) + Chr(10) + CStr(Finish2 - Start2) + " seconds to Load Grid!", 48
   End If

   GoTo OkayEnd

DynasetErr:
   ShowError
   ResetMouse Me
   MsgBar "", False
   ResetMouse Me
   Unload Me
   Exit Sub
   Resume OkayEnd

OkayEnd:
   ResetMouse Me
   MsgBar "", False

End Sub

Sub Form_Resize ()
  On Error Resume Next

  'resize grid to window
  If WindowState <> 1 Then   'not minimized
    cGrid.Height = Height - 900
    cGrid.Width = Width - 100
  End If
End Sub

Sub Form_Unload (Cancel As Integer)
  On Error Resume Next

  'unload the find form
  Unload FFindForm

  'close the associated dynaset
  FDS.Close
  MsgBar "", False
End Sub

Sub MoreButton_Click ()
  Dim ret As Integer   'return value from loadgrid

  On Error Resume Next

  MsgBar "Getting more records", True
  If FDS.EOF <> True Then
    SetHourGlass Me

    ret = LoadGrid(cGrid, FDS, FDynSt, gwMaxGridRows, FCurrentRow)
    If ret = False Then
      'failed so bail out of form
      FDS.Close
      Unload Me
    End If
    'set new current row
    FCurrentRow = FCurrentRow + ret

    ResetMouse Me
  End If
  MsgBar "", False

End Sub

Sub NextButton_Click ()
   Dim c As Integer      'current column

   On Error GoTo GoNextError

   c = cGrid.Col
   cGrid.Col = 0
   If cGrid.Text = "" Then
     Beep
   ElseIf cGrid.Row = gwMaxGridRows Then
     MoreButton_Click
   Else
     cGrid.SetFocus
     SendKeys "{Down}"
   End If
   cGrid.Col = c

   GoTo GoNextEnd

GoNextError:
   ShowError
   Resume GoNextEnd

GoNextEnd:

End Sub

'needed for multi-user situations so
'new records can be viewed imediately
Sub RefreshButton_Click ()
   Dim numbrows As Long

   On Error GoTo RefreshError

   MsgBar "Reopening Dynaset", True
   SetHourGlass Me
'   Set FDS = gCurrentDB.CreateDynaset(FDS.Name)
   Set FDS = gCurrentDB.CreateSnapshot(FDS.Name)

   FNumbRows = GetNumbRecsSS(FDS)
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     Caption = "Dynaset: " + FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
   ElseIf FNumbRows > gwMaxGridRows Then
     Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " rows]"
   End If

   If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then
     Unload Me
     Exit Sub
   End If

  GoTo RefreshEnd

RefreshError:
  ShowError
  Resume RefreshEnd

RefreshEnd:
  ResetMouse Me
  MsgBar "", False

End Sub

Sub SortButton_Click ()
  On Error GoTo SortErr

'  Dim ds1 As dynaset, ds2 As dynaset
  Dim ds1 As snapshot, ds2 As snapshot

  Dim numbrows As Long    'local number of rows

  Set ds1 = FDS            'save the dynaset
Dim i As Integer, r As Integer, c As Integer

   'On Error GoTo FindErr

   'load the column names into the filter form
   'the 1st time it is loaded
   If fSort.cFieldList.ListCount = 0 Then
     fSort.cFieldList.Clear
     r = cGrid.Row
     c = cGrid.Col
     cGrid.Row = 0
     cGrid.Col = 0
     For i = 1 To cGrid.Cols - 1
       cGrid.Col = cGrid.Col + 1
       fSort.cFieldList.AddItem cGrid.Text
     Next
     cGrid.Row = r
     cGrid.Col = c
   End If

  fSort.Show MODAL
  'SortStr = InputBox("Enter Sort Column:")
  If SortStr = "" Then Exit Sub

  FDS.Sort = SortStr
'  Set ds2 = FDS.CreateDynaset()            'establish the Sort
  Set ds2 = FDS.CreateSnapshot()            'establish the Sort
  Set FDS = ds2            'assign back to original dynaset object

  'everything must be okay so redisplay form on 1st record
  FNumbRows = GetNumbRecsSS(FDS)          'query numb of recs
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     Caption = "Dynaset: " + FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     Caption = "Dynaset: " + FTblName + " [" + CStr(FNumbRows) + " rows]"
   End If
  If LoadGrid(cGrid, FDS, FDynSt, numbrows, 0) = False Then
    Unload Me
    Exit Sub
  End If
  GoTo SortEnd

SortErr:
  ShowError
  Set FDS = ds1            're-assign back to original
  Resume SortEnd

SortEnd:

End Sub